The quintic, the icosahedron and elliptic curves

Solving a quintic using elliptic curves

Set up the invariant forms

zeta=Exp[2*Pi*I/5];
m=zeta+zeta^4;
n=zeta^2+zeta^3;

VForm=u*v*(u^10+11*u^5*v^5-v^10);
FForm=-u^20-v^20+228*(u^15*v^5 - u^5*v^15)-494*u^10*v^10;
EForm=u^30+v^30+522*(u^25*v^5-u^5*v^25)-10005*(u^20*v^10+u^10*v^20);

Check they satisfy the correct relation.

Expand[EForm^2-(1728*VForm^5 - FForm^3)]

Set up the octahedral functions

AA[k_]:=zeta^k*u^2 +zeta^(4*k)*v^2;
BB[k_]:=zeta^k*u^2-2*n*u*v-zeta^(4*k)*v^2;
CC[k_]:=zeta^k*u^2-2*m*u*v-zeta^(4*k)*v^2;
t[k_]:=AA[k]*BB[k]*CC[k];
x[k_]:=-VForm^2/EForm*t[k];

First choose a Brioschi quintic.

Choose a random Brioschi parameter B.

B=-5

So the quintic polynomial whose roots we are finding is:

Q = X^5+10*B*X^3+45*B^2*X+B^2

Here are the five roots of our quintic, calculated numerically.

N[Solve[Q==0, X]]

Now compute the associated elliptic curve

The j-invariant of the associated elliptic curve is:

j = 1728 + 1/B

To put this in Weierstrass form we calculate coefficients c2 and c3 consistent with j (there is a 1-parameter family of choices, we have fixed a specific formula)

g2=-3*j/(1728-j);
g3=j/(1728-j);

So the elliptic curve is .

Epoly = 4*x^3-g2*x-g3

Confirm that the j-invariant of this elliptic curve is j:

1728*g2^3/(g2^3 - 27g3^2)

Calculate the roots of the cubic

rootsCubic=Solve[Epoly==0, x]

The roots, explicitly.

e1=x/.rootsCubic[[1]]
e2=x/.rootsCubic[[2]]
e3=x/.rootsCubic[[3]]

Define Cremona and Thongjunthug’s complex AGM

AGM[a_, b_, numSteps_]:= Module[{i, a0, b0, acur, bcur, anext, bnext, sqroot},
acur = a;
bcur = b;

For[i=1, i<=numSteps, i++, 
anext = N[1/2*(acur + bcur)];
sqroot=N[Sqrt[acur*bcur]];
bnext = If[Re[sqroot]>=0, sqroot, -sqroot];
acur=anext;
bcur=bnext;
];
acur
];

Test it out.

AGM[1, 1+I, 10]

Calculate the periods of the associated lattice via complex AGM

We need to calculate the periods  and  of the elliptic curve.

a0 = Sqrt[e1 - e3];
b0 = Sqrt[e1-e2];
b0 = If[Re[b0/a0]>=0,b0, -b0];
w1=Pi/AGM[a0,b0, 10]

a0 = Sqrt[e2 - e3];
b0 = Sqrt[e2-e1];
b0 = If[Re[b0/a0]>=0,b0, -b0];
w2=Pi/AGM[a0,b0, 10]

tau=If[Im[w2/w1]>=0, w2/w1, w1/w2]

Compute j5 of tau using Rogers-Ramanujan identity

FiniteRR[q_,numTerms_] :=q^(1/5)*ContinuedFractionK[q^i, 1, {i, 0, numTerms}]

q=Exp[2*Pi*I*tau]

prefactor=Exp[2*Pi*I*tau/5]

So, the point  on the round icosahedron (i.e. S^2) associated to our elliptic curve E and its primitive basis is:

Z=N[prefactor*ContinuedFractionK[q^i, 1, {i, 0, 10}], 10]

Check how quickly it is converging (should be quadratic convergence).

TableForm[Table[{n,N[prefactor*ContinuedFractionK[q^i, 1, {i, 0, n}], 40]}, {n, 1, 5}]]

Calculate the octahedral functions - hopefully equals the roots!

We now calculate the octahedral functions  for the parameter

calcRoots=Table[x[i]/.{u->Z, v->1}, {i, 1, 5}]

actualRoots=X/.N[Solve[Q==0, X]]

It worked!!

Monodromy of the roots of a Brioschi quintic

Click and drag the Brioschi parameter below to see the dance of the roots.

Clear[a]

F[x_,a_]:=x^5+10*a*x^3 + 45*a^2*x + a^2

RootsOfPoly[a_]:=(
(* Takes a point{a_1,a_2} and  returns the root {x,y} where F(a_1 + a_2*I, x+yI) = 0 *)
ReIm[x/.NSolve[F[x,a[[1]]+I*a[[2]]]==0, x]]
);

axmin=-0.001;
ajumps=2; (* jumps between a=0 and a=-1/1728 *)
astepx = 1/(1728*ajumps);  
astepy = 1/(1728*ajumps);
axmax=0.0005;
aymin=-0.001;
aymax=0.001;
adefaultx=-ajumps*astepx/2;
adefaulty=ajumps*astepy/2; (*ajumps*astepy;*)
rootsxmin=-0.1;
rootsxmax=0.1;
rootsymin=-0.1;
rootsymax=0.1;

DynamicModule[
{a={adefaultx, adefaulty}}, 
Row[
{
LocatorPane[
Dynamic[a],
Graphics[
{
{PointSize[Large], Blue, Point[{{-1/1728, 0}, {0,0}}]},
Dynamic[Text["    a=" <>ToString[a[[1]]]<>"+"<>ToString[a[[2]]]<>"i", a, {-1,0}]]
}, 
PlotRange->{{axmin,axmax},{aymin,aymax}}, Axes->True, ImageSize->400, 
Frame->True,
FrameTicks->{None,  None},
FrameLabel->"a plane"],
{{axmin,aymin},{axmax, aymax}}],
Graphics[
{
{
PointSize[Large], Pink, Dynamic[Point[RootsOfPoly[a]]]
},
Dynamic[Text[Style["  1", 20, FontFamily->"CMU Serif"], RootsOfPoly[a][[1]]]],
Dynamic[Text[Style["  2", 20, FontFamily->"CMU Serif"],RootsOfPoly[a][[2]]]],
Dynamic[Text[Style["  3", 20, FontFamily->"CMU Serif"],RootsOfPoly[a][[3]]]],
Dynamic[Text[Style["  4", 20, FontFamily->"CMU Serif"],RootsOfPoly[a][[4]]]],
Dynamic[Text[Style["  5", 20, FontFamily->"CMU Serif"],RootsOfPoly[a][[5]]]]
},
PlotRange->{{rootsxmin, rootsxmax},{rootsymin, rootsymax}},
Frame->True,
FrameLabel->"Roots of  (x^5)+10 a (x^3) + 45 (a^2) x + (a^2)=0",
Axes->True, 
ImageSize->600]
(*RootsOfPoly[Dynamic[a]]*)
}
]
]